home *** CD-ROM | disk | FTP | other *** search
/ Skunkware 98 / Skunkware 98.iso / src / interp / perl-5.003.tar.gz / perl-5.003.tar / perl-5.003 / lib / ExtUtils / xsubpp < prev   
Text File  |  1996-03-25  |  31KB  |  1,219 lines
  1. #!./miniperl
  2.  
  3. =head1 NAME
  4.  
  5. xsubpp - compiler to convert Perl XS code into C code
  6.  
  7. =head1 SYNOPSIS
  8.  
  9. B<xsubpp> [B<-v>] [B<-C++>] [B<-except>] [B<-s pattern>] [B<-prototypes>] [B<-noversioncheck>] [B<-typemap typemap>]... file.xs
  10.  
  11. =head1 DESCRIPTION
  12.  
  13. I<xsubpp> will compile XS code into C code by embedding the constructs
  14. necessary to let C functions manipulate Perl values and creates the glue
  15. necessary to let Perl access those functions.  The compiler uses typemaps to
  16. determine how to map C function parameters and variables to Perl values.
  17.  
  18. The compiler will search for typemap files called I<typemap>.  It will use
  19. the following search path to find default typemaps, with the rightmost
  20. typemap taking precedence.
  21.  
  22.     ../../../typemap:../../typemap:../typemap:typemap
  23.  
  24. =head1 OPTIONS
  25.  
  26. =over 5
  27.  
  28. =item B<-C++>
  29.  
  30. Adds ``extern "C"'' to the C code.
  31.  
  32.  
  33. =item B<-except>
  34.  
  35. Adds exception handling stubs to the C code.
  36.  
  37. =item B<-typemap typemap>
  38.  
  39. Indicates that a user-supplied typemap should take precedence over the
  40. default typemaps.  This option may be used multiple times, with the last
  41. typemap having the highest precedence.
  42.  
  43. =item B<-v>
  44.  
  45. Prints the I<xsubpp> version number to standard output, then exits.
  46.  
  47. =item B<-prototypes>
  48.  
  49. By default I<xsubpp> will not automatically generate prototype code for
  50. all xsubs. This flag will enable prototypes.
  51.  
  52. =item B<-noversioncheck>
  53.  
  54. Disables the run time test that determines if the object file (derived
  55. from the C<.xs> file) and the C<.pm> files have the same version
  56. number.
  57.  
  58. =back
  59.  
  60. =head1 ENVIRONMENT
  61.  
  62. No environment variables are used.
  63.  
  64. =head1 AUTHOR
  65.  
  66. Larry Wall
  67.  
  68. =head1 MODIFICATION HISTORY
  69.  
  70. See the file F<changes.pod>.
  71.  
  72. =head1 SEE ALSO
  73.  
  74. perl(1), perlxs(1), perlxstut(1), perlapi(1)
  75.  
  76. =cut
  77.  
  78. # Global Constants
  79. $XSUBPP_version = "1.935";
  80. require 5.002;
  81. use vars '$cplusplus';
  82.  
  83. sub Q ;
  84.  
  85. $FH = 'File0000' ;
  86.  
  87. $usage = "Usage: xsubpp [-v] [-C++] [-except] [-prototypes] [-noversioncheck] [-s pattern] [-typemap typemap]... file.xs\n";
  88.  
  89. $proto_re = "[" . quotemeta('\$%&*@;') . "]" ;
  90.  
  91. $except = "";
  92. $WantPrototypes = -1 ;
  93. $WantVersionChk = 1 ;
  94. $ProtoUsed = 0 ;
  95. SWITCH: while (@ARGV and $ARGV[0] =~ /^-./) {
  96.     $flag = shift @ARGV;
  97.     $flag =~ s/^-// ;
  98.     $spat = shift,    next SWITCH    if $flag eq 's';
  99.     $cplusplus = 1,    next SWITCH    if $flag eq 'C++';
  100.     $WantPrototypes = 0, next SWITCH    if $flag eq 'noprototypes';
  101.     $WantPrototypes = 1, next SWITCH    if $flag eq 'prototypes';
  102.     $WantVersionChk = 0, next SWITCH    if $flag eq 'noversioncheck';
  103.     $WantVersionChk = 1, next SWITCH    if $flag eq 'versioncheck';
  104.     $except = " TRY",    next SWITCH    if $flag eq 'except';
  105.     push(@tm,shift),    next SWITCH    if $flag eq 'typemap';
  106.     (print "xsubpp version $XSUBPP_version\n"), exit      
  107.     if $flag eq 'v';
  108.     die $usage;
  109. }
  110. if ($WantPrototypes == -1)
  111.   { $WantPrototypes = 0}
  112. else
  113.   { $ProtoUsed = 1 }
  114.  
  115.  
  116. @ARGV == 1 or die $usage;
  117. ($dir, $filename) = $ARGV[0] =~ m#(.*)/(.*)#
  118.     or ($dir, $filename) = $ARGV[0] =~ m#(.*[>\]])(.*)#
  119.     or ($dir, $filename) = ('.', $ARGV[0]);
  120. chdir($dir);
  121. # Check for VMS; Config.pm may not be installed yet, but this routine
  122. # is built into VMS perl
  123. if (defined(&VMS::Filespec::vmsify)) { $Is_VMS = 1; $pwd = $ENV{DEFAULT}; }
  124. else                                 { $Is_VMS = 0; chomp($pwd = `pwd`);   }
  125.  
  126. ++ $IncludedFiles{$ARGV[0]} ;
  127.  
  128. my(@XSStack) = ({type => 'none'});    # Stack of conditionals and INCLUDEs
  129. my($XSS_work_idx, $cpp_next_tmp) = (0, "XSubPPtmpAAAA");
  130.  
  131. sub TrimWhitespace
  132. {
  133.     $_[0] =~ s/^\s+|\s+$//go ;
  134. }
  135.  
  136. sub TidyType
  137. {
  138.     local ($_) = @_ ;
  139.  
  140.     # rationalise any '*' by joining them into bunches and removing whitespace
  141.     s#\s*(\*+)\s*#$1#g;
  142.     s#(\*+)# $1 #g ;
  143.  
  144.     # change multiple whitespace into a single space
  145.     s/\s+/ /g ;
  146.     
  147.     # trim leading & trailing whitespace
  148.     TrimWhitespace($_) ;
  149.  
  150.     $_ ;
  151. }
  152.  
  153. $typemap = shift @ARGV;
  154. foreach $typemap (@tm) {
  155.     die "Can't find $typemap in $pwd\n" unless -r $typemap;
  156. }
  157. unshift @tm, qw(../../../../lib/ExtUtils/typemap ../../../lib/ExtUtils/typemap
  158.                 ../../lib/ExtUtils/typemap ../../../typemap ../../typemap
  159.                 ../typemap typemap);
  160. foreach $typemap (@tm) {
  161.     next unless -e $typemap ;
  162.     # skip directories, binary files etc.
  163.     warn("Warning: ignoring non-text typemap file '$typemap'\n"), next 
  164.     unless -T $typemap ;
  165.     open(TYPEMAP, $typemap) 
  166.     or warn ("Warning: could not open typemap file '$typemap': $!\n"), next;
  167.     $mode = 'Typemap';
  168.     $junk = "" ;
  169.     $current = \$junk;
  170.     while (<TYPEMAP>) {
  171.     next if /^\s*#/;
  172.     if (/^INPUT\s*$/)   { $mode = 'Input';   $current = \$junk;  next; }
  173.     if (/^OUTPUT\s*$/)  { $mode = 'Output';  $current = \$junk;  next; }
  174.     if (/^TYPEMAP\s*$/) { $mode = 'Typemap'; $current = \$junk;  next; }
  175.     if ($mode eq 'Typemap') {
  176.         chomp;
  177.         my $line = $_ ;
  178.             TrimWhitespace($_) ;
  179.         # skip blank lines and comment lines
  180.         next if /^$/ or /^#/ ;
  181.         my($type,$kind, $proto) = /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/ or
  182.         warn("Warning: File '$typemap' Line $. '$line' TYPEMAP entry needs 2 or 3 columns\n"), next;
  183.             $type = TidyType($type) ;
  184.         $type_kind{$type} = $kind ;
  185.             # prototype defaults to '$'
  186.             $proto = '$' unless $proto ;
  187.             warn("Warning: File '$typemap' Line $. '$line' Invalid prototype '$proto'\n") 
  188.                 unless ValidProtoString($proto) ;
  189.             $proto_letter{$type} = C_string($proto) ;
  190.     }
  191.     elsif (/^\s/) {
  192.         $$current .= $_;
  193.     }
  194.     elsif ($mode eq 'Input') {
  195.         s/\s+$//;
  196.         $input_expr{$_} = '';
  197.         $current = \$input_expr{$_};
  198.     }
  199.     else {
  200.         s/\s+$//;
  201.         $output_expr{$_} = '';
  202.         $current = \$output_expr{$_};
  203.     }
  204.     }
  205.     close(TYPEMAP);
  206. }
  207.  
  208. foreach $key (keys %input_expr) {
  209.     $input_expr{$key} =~ s/\n+$//;
  210. }
  211.  
  212. $END = "!End!\n\n";        # "impossible" keyword (multiple newline)
  213.  
  214. # Match an XS keyword
  215. $BLOCK_re= '\s*(' . join('|', qw(
  216.     REQUIRE BOOT CASE PREINIT INPUT INIT CODE PPCODE OUTPUT 
  217.     CLEANUP ALIAS PROTOTYPES PROTOTYPE VERSIONCHECK INCLUDE
  218.     )) . "|$END)\\s*:";
  219.  
  220. # Input:  ($_, @line) == unparsed input.
  221. # Output: ($_, @line) == (rest of line, following lines).
  222. # Return: the matched keyword if found, otherwise 0
  223. sub check_keyword {
  224.     $_ = shift(@line) while !/\S/ && @line;
  225.     s/^(\s*)($_[0])\s*:\s*(?:#.*)?/$1/s && $2;
  226. }
  227.  
  228.  
  229. sub print_section {
  230.     $_ = shift(@line) while !/\S/ && @line;
  231.     for (;  defined($_) && !/^$BLOCK_re/o;  $_ = shift(@line)) {
  232.     print "$_\n";
  233.     }
  234. }
  235.  
  236. sub process_keyword($)
  237. {
  238.     my($pattern) = @_ ;
  239.     my $kwd ;
  240.  
  241.     &{"${kwd}_handler"}() 
  242.         while $kwd = check_keyword($pattern) ;
  243. }
  244.  
  245. sub CASE_handler {
  246.     blurt ("Error: `CASE:' after unconditional `CASE:'")
  247.     if $condnum && $cond eq '';
  248.     $cond = $_;
  249.     TrimWhitespace($cond);
  250.     print "   ", ($condnum++ ? " else" : ""), ($cond ? " if ($cond)\n" : "\n");
  251.     $_ = '' ;
  252. }
  253.  
  254. sub INPUT_handler {
  255.     for (;  !/^$BLOCK_re/o;  $_ = shift(@line)) {
  256.     last if /^\s*NOT_IMPLEMENTED_YET/;
  257.     next unless /\S/;    # skip blank lines 
  258.  
  259.     TrimWhitespace($_) ;
  260.     my $line = $_ ;
  261.  
  262.     # remove trailing semicolon if no initialisation
  263.     s/\s*;$//g unless /=/ ;
  264.  
  265.     # check for optional initialisation code
  266.     my $var_init = '' ;
  267.     $var_init = $1 if s/\s*(=.*)$//s ;
  268.     $var_init =~ s/"/\\"/g;
  269.  
  270.     s/\s+/ /g;
  271.     my ($var_type, $var_addr, $var_name) = /^(.*?[^& ]) *(\&?) *\b(\w+)$/s
  272.         or blurt("Error: invalid argument declaration '$line'"), next;
  273.  
  274.     # Check for duplicate definitions
  275.     blurt ("Error: duplicate definition of argument '$var_name' ignored"), next
  276.         if $arg_list{$var_name} ++  ;
  277.  
  278.     $thisdone |= $var_name eq "THIS";
  279.     $retvaldone |= $var_name eq "RETVAL";
  280.     $var_types{$var_name} = $var_type;
  281.     print "\t" . &map_type($var_type);
  282.     $var_num = $args_match{$var_name};
  283.  
  284.         $proto_arg[$var_num] = ProtoString($var_type) 
  285.         if $var_num ;
  286.     if ($var_addr) {
  287.         $var_addr{$var_name} = 1;
  288.         $func_args =~ s/\b($var_name)\b/&$1/;
  289.     }
  290.     if ($var_init =~ /^=\s*NO_INIT\s*;?\s*$/) {
  291.         print "\t$var_name;\n";
  292.     } elsif ($var_init =~ /\S/) {
  293.         &output_init($var_type, $var_num, "$var_name $var_init");
  294.     } elsif ($var_num) {
  295.         # generate initialization code
  296.         &generate_init($var_type, $var_num, $var_name);
  297.     } else {
  298.         print ";\n";
  299.     }
  300.     }
  301. }
  302.  
  303. sub OUTPUT_handler {
  304.     for (;  !/^$BLOCK_re/o;  $_ = shift(@line)) {
  305.     next unless /\S/;
  306.     my ($outarg, $outcode) = /^\s*(\S+)\s*(.*?)\s*$/s ;
  307.     blurt ("Error: duplicate OUTPUT argument '$outarg' ignored"), next
  308.         if $outargs{$outarg} ++ ;
  309.     if (!$gotRETVAL and $outarg eq 'RETVAL') {
  310.         # deal with RETVAL last
  311.         $RETVAL_code = $outcode ;
  312.         $gotRETVAL = 1 ;
  313.         next ;
  314.     }
  315.     blurt ("Error: OUTPUT $outarg not an argument"), next
  316.         unless defined($args_match{$outarg});
  317.     blurt("Error: No input definition for OUTPUT argument '$outarg' - ignored"), next
  318.         unless defined $var_types{$outarg} ;
  319.     if ($outcode) {
  320.         print "\t$outcode\n";
  321.     } else {
  322.         $var_num = $args_match{$outarg};
  323.         &generate_output($var_types{$outarg}, $var_num, $outarg); 
  324.     }
  325.     }
  326. }
  327.  
  328. sub CLEANUP_handler() { print_section() } 
  329. sub PREINIT_handler() { print_section() } 
  330. sub INIT_handler()    { print_section() } 
  331.  
  332. sub GetAliases
  333. {
  334.     my ($line) = @_ ;
  335.     my ($orig) = $line ;
  336.     my ($alias) ;
  337.     my ($value) ;
  338.  
  339.     # Parse alias definitions
  340.     # format is
  341.     #    alias = value alias = value ...
  342.  
  343.     while ($line =~ s/^\s*([\w:]+)\s*=\s*(\w+)\s*//) {
  344.         $alias = $1 ;
  345.         $orig_alias = $alias ;
  346.         $value = $2 ;
  347.  
  348.         # check for optional package definition in the alias
  349.     $alias = $Packprefix . $alias if $alias !~ /::/ ;
  350.         
  351.         # check for duplicate alias name & duplicate value
  352.     Warn("Warning: Ignoring duplicate alias '$orig_alias'")
  353.         if defined $XsubAliases{$alias} ;
  354.  
  355.     Warn("Warning: Aliases '$orig_alias' and '$XsubAliasValues{$value}' have identical values")
  356.         if $XsubAliasValues{$value} ;
  357.  
  358.     $XsubAliases = 1;
  359.     $XsubAliases{$alias} = $value ;
  360.     $XsubAliasValues{$value} = $orig_alias ;
  361.     }
  362.  
  363.     blurt("Error: Cannot parse ALIAS definitions from '$orig'")
  364.         if $line ;
  365. }
  366.  
  367. sub ALIAS_handler ()
  368. {
  369.     for (;  !/^$BLOCK_re/o;  $_ = shift(@line)) {
  370.     next unless /\S/;
  371.     TrimWhitespace($_) ;
  372.         GetAliases($_) if $_ ;
  373.     }
  374. }
  375.  
  376. sub REQUIRE_handler ()
  377. {
  378.     # the rest of the current line should contain a version number
  379.     my ($Ver) = $_ ;
  380.  
  381.     TrimWhitespace($Ver) ;
  382.  
  383.     death ("Error: REQUIRE expects a version number")
  384.     unless $Ver ;
  385.  
  386.     # check that the version number is of the form n.n
  387.     death ("Error: REQUIRE: expected a number, got '$Ver'")
  388.     unless $Ver =~ /^\d+(\.\d*)?/ ;
  389.  
  390.     death ("Error: xsubpp $Ver (or better) required--this is only $XSUBPP_version.")
  391.         unless $XSUBPP_version >= $Ver ; 
  392. }
  393.  
  394. sub VERSIONCHECK_handler ()
  395. {
  396.     # the rest of the current line should contain either ENABLE or
  397.     # DISABLE
  398.  
  399.     TrimWhitespace($_) ;
  400.  
  401.     # check for ENABLE/DISABLE
  402.     death ("Error: VERSIONCHECK: ENABLE/DISABLE")
  403.         unless /^(ENABLE|DISABLE)/i ;
  404.  
  405.     $WantVersionChk = 1 if $1 eq 'ENABLE' ;
  406.     $WantVersionChk = 0 if $1 eq 'DISABLE' ;
  407.  
  408. }
  409.  
  410. sub PROTOTYPE_handler ()
  411. {
  412.     my $specified ;
  413.  
  414.     death("Error: Only 1 PROTOTYPE definition allowed per xsub") 
  415.         if $proto_in_this_xsub ++ ;
  416.  
  417.     for (;  !/^$BLOCK_re/o;  $_ = shift(@line)) {
  418.     next unless /\S/;
  419.     $specified = 1 ;
  420.     TrimWhitespace($_) ;
  421.         if ($_ eq 'DISABLE') {
  422.        $ProtoThisXSUB = 0 
  423.         }
  424.         elsif ($_ eq 'ENABLE') {
  425.        $ProtoThisXSUB = 1 
  426.         }
  427.         else {
  428.             # remove any whitespace
  429.             s/\s+//g ;
  430.             death("Error: Invalid prototype '$_'")
  431.                 unless ValidProtoString($_) ;
  432.             $ProtoThisXSUB = C_string($_) ;
  433.         }
  434.     }
  435.  
  436.     # If no prototype specified, then assume empty prototype ""
  437.     $ProtoThisXSUB = 2 unless $specified ;
  438.  
  439.     $ProtoUsed = 1 ;
  440.  
  441. }
  442.  
  443. sub PROTOTYPES_handler ()
  444. {
  445.     # the rest of the current line should contain either ENABLE or
  446.     # DISABLE 
  447.  
  448.     TrimWhitespace($_) ;
  449.  
  450.     # check for ENABLE/DISABLE
  451.     death ("Error: PROTOTYPES: ENABLE/DISABLE")
  452.         unless /^(ENABLE|DISABLE)/i ;
  453.  
  454.     $WantPrototypes = 1 if $1 eq 'ENABLE' ;
  455.     $WantPrototypes = 0 if $1 eq 'DISABLE' ;
  456.     $ProtoUsed = 1 ;
  457.  
  458. }
  459.  
  460. sub INCLUDE_handler ()
  461. {
  462.     # the rest of the current line should contain a valid filename
  463.  
  464.     TrimWhitespace($_) ;
  465.  
  466.     death("INCLUDE: filename missing")
  467.         unless $_ ;
  468.  
  469.     death("INCLUDE: output pipe is illegal")
  470.         if /^\s*\|/ ;
  471.  
  472.     # simple minded recursion detector
  473.     death("INCLUDE loop detected")
  474.         if $IncludedFiles{$_} ;
  475.  
  476.     ++ $IncludedFiles{$_} unless /\|\s*$/ ;
  477.  
  478.     # Save the current file context.
  479.     push(@XSStack, {
  480.     type        => 'file',
  481.         LastLine        => $lastline,
  482.         LastLineNo      => $lastline_no,
  483.         Line            => \@line,
  484.         LineNo          => \@line_no,
  485.         Filename        => $filename,
  486.         Handle          => $FH,
  487.         }) ;
  488.  
  489.     ++ $FH ;
  490.  
  491.     # open the new file
  492.     open ($FH, "$_") or death("Cannot open '$_': $!") ;
  493.  
  494.     print Q<<"EOF" ;
  495. #
  496. #/* INCLUDE:  Including '$_' from '$filename' */
  497. #
  498. EOF
  499.  
  500.     $filename = $_ ;
  501.  
  502.     # Prime the pump by reading the first 
  503.     # non-blank line
  504.  
  505.     # skip leading blank lines
  506.     while (<$FH>) {
  507.         last unless /^\s*$/ ;
  508.     }
  509.  
  510.     $lastline = $_ ;
  511.     $lastline_no = $. ;
  512.  
  513. }
  514.  
  515. sub PopFile()
  516. {
  517.     return 0 unless $XSStack[-1]{type} eq 'file' ;
  518.  
  519.     my $data     = pop @XSStack ;
  520.     my $ThisFile = $filename ;
  521.     my $isPipe   = ($filename =~ /\|\s*$/) ;
  522.  
  523.     -- $IncludedFiles{$filename}
  524.         unless $isPipe ;
  525.  
  526.     close $FH ;
  527.  
  528.     $FH         = $data->{Handle} ;
  529.     $filename   = $data->{Filename} ;
  530.     $lastline   = $data->{LastLine} ;
  531.     $lastline_no = $data->{LastLineNo} ;
  532.     @line       = @{ $data->{Line} } ;
  533.     @line_no    = @{ $data->{LineNo} } ;
  534.  
  535.     if ($isPipe and $? ) {
  536.         -- $lastline_no ;
  537.         print STDERR "Error reading from pipe '$ThisFile': $! in $filename, line $lastline_no\n"  ;
  538.         exit 1 ;
  539.     }
  540.  
  541.     print Q<<"EOF" ;
  542. #
  543. #/* INCLUDE: Returning to '$filename' from '$ThisFile' */
  544. #
  545. EOF
  546.  
  547.     return 1 ;
  548. }
  549.  
  550. sub ValidProtoString ($)
  551. {
  552.     my($string) = @_ ;
  553.  
  554.     if ( $string =~ /^$proto_re+$/ ) {
  555.         return $string ;
  556.     }
  557.  
  558.     return 0 ;
  559. }
  560.  
  561. sub C_string ($)
  562. {
  563.     my($string) = @_ ;
  564.  
  565.     $string =~ s[\\][\\\\]g ;
  566.     $string ;
  567. }
  568.  
  569. sub ProtoString ($)
  570. {
  571.     my ($type) = @_ ;
  572.  
  573.     $proto_letter{$type} or '$' ;
  574. }
  575.  
  576. sub check_cpp {
  577.     my @cpp = grep(/^\#\s*(?:if|e\w+)/, @line);
  578.     if (@cpp) {
  579.     my ($cpp, $cpplevel);
  580.     for $cpp (@cpp) {
  581.         if ($cpp =~ /^\#\s*if/) {
  582.         $cpplevel++;
  583.         } elsif (!$cpplevel) {
  584.         Warn("Warning: #else/elif/endif without #if in this function");
  585.         print STDERR "    (precede it with a blank line if the matching #if is outside the function)\n"
  586.             if $XSStack[-1]{type} eq 'if';
  587.         return;
  588.         } elsif ($cpp =~ /^\#\s*endif/) {
  589.         $cpplevel--;
  590.         }
  591.     }
  592.     Warn("Warning: #if without #endif in this function") if $cpplevel;
  593.     }
  594. }
  595.  
  596.  
  597. sub Q {
  598.     my($text) = @_;
  599.     $text =~ s/^#//gm;
  600.     $text =~ s/\[\[/{/g;
  601.     $text =~ s/\]\]/}/g;
  602.     $text;
  603. }
  604.  
  605. open($FH, $filename) or die "cannot open $filename: $!\n";
  606.  
  607. # Identify the version of xsubpp used
  608. print <<EOM ;
  609. /*
  610.  * This file was generated automatically by xsubpp version $XSUBPP_version from the 
  611.  * contents of $filename. Don't edit this file, edit $filename instead.
  612.  *
  613.  *    ANY CHANGES MADE HERE WILL BE LOST! 
  614.  *
  615.  */
  616.  
  617. EOM
  618.  
  619.  
  620. while (<$FH>) {
  621.     last if ($Module, $Package, $Prefix) =
  622.     /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/;
  623.     print $_;
  624. }
  625. &Exit unless defined $_;
  626.  
  627. $lastline    = $_;
  628. $lastline_no = $.;
  629.  
  630.  
  631. # Read next xsub into @line from ($lastline, <$FH>).
  632. sub fetch_para {
  633.     # parse paragraph
  634.     death ("Error: Unterminated `#if/#ifdef/#ifndef'")
  635.     if !defined $lastline && $XSStack[-1]{type} eq 'if';
  636.     @line = ();
  637.     @line_no = () ;
  638.     return PopFile() if !defined $lastline;
  639.  
  640.     if ($lastline =~
  641.     /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/) {
  642.     $Module = $1;
  643.     $Package = defined($2) ? $2 : '';    # keep -w happy
  644.     $Prefix  = defined($3) ? $3 : '';    # keep -w happy
  645.     ($Module_cname = $Module) =~ s/\W/_/g;
  646.     ($Packid = $Package) =~ tr/:/_/;
  647.     $Packprefix = $Package;
  648.     $Packprefix .= "::" if $Packprefix ne "";
  649.     $lastline = "";
  650.     }
  651.  
  652.     for(;;) {
  653.     if ($lastline !~ /^\s*#/ ||
  654.         # CPP directives:
  655.         #    ANSI:    if ifdef ifndef elif else endif define undef
  656.         #        line error pragma
  657.         #    gcc:    warning include_next
  658.         #   obj-c:    import
  659.         #   others:    ident (gcc notes that some cpps have this one)
  660.         $lastline =~ /^#[ \t]*(?:(?:if|ifn?def|elif|else|endif|define|undef|pragma|error|warning|line\s+\d+|ident)\b|(?:include(?:_next)?|import)\s*["<].*[>"])/) {
  661.         last if $lastline =~ /^\S/ && @line && $line[-1] eq "";
  662.         push(@line, $lastline);
  663.         push(@line_no, $lastline_no) ;
  664.     }
  665.  
  666.     # Read next line and continuation lines
  667.     last unless defined($lastline = <$FH>);
  668.     $lastline_no = $.;
  669.     my $tmp_line;
  670.     $lastline .= $tmp_line
  671.         while ($lastline =~ /\\$/ && defined($tmp_line = <$FH>));
  672.         
  673.     chomp $lastline;
  674.     $lastline =~ s/^\s+$//;
  675.     }
  676.     pop(@line), pop(@line_no) while @line && $line[-1] eq "";
  677.     1;
  678. }
  679.  
  680. PARAGRAPH:
  681. while (fetch_para()) {
  682.     # Print initial preprocessor statements and blank lines
  683.     while (@line && $line[0] !~ /^[^\#]/) {
  684.     my $line = shift(@line);
  685.     print $line, "\n";
  686.     next unless $line =~ /^\#\s*((if)(?:n?def)?|elsif|else|endif)\b/;
  687.     my $statement = $+;
  688.     if ($statement eq 'if') {
  689.         $XSS_work_idx = @XSStack;
  690.         push(@XSStack, {type => 'if'});
  691.     } else {
  692.         death ("Error: `$statement' with no matching `if'")
  693.         if $XSStack[-1]{type} ne 'if';
  694.         if ($XSStack[-1]{varname}) {
  695.         push(@InitFileCode, "#endif\n");
  696.         push(@BootCode,     "#endif");
  697.         }
  698.  
  699.         my(@fns) = keys %{$XSStack[-1]{functions}};
  700.         if ($statement ne 'endif') {
  701.         # Hide the functions defined in other #if branches, and reset.
  702.         @{$XSStack[-1]{other_functions}}{@fns} = (1) x @fns;
  703.         @{$XSStack[-1]}{qw(varname functions)} = ('', {});
  704.         } else {
  705.         my($tmp) = pop(@XSStack);
  706.         0 while (--$XSS_work_idx
  707.              && $XSStack[$XSS_work_idx]{type} ne 'if');
  708.         # Keep all new defined functions
  709.         push(@fns, keys %{$tmp->{other_functions}});
  710.         @{$XSStack[$XSS_work_idx]{functions}}{@fns} = (1) x @fns;
  711.         }
  712.     }
  713.     }
  714.  
  715.     next PARAGRAPH unless @line;
  716.  
  717.     if ($XSS_work_idx && !$XSStack[$XSS_work_idx]{varname}) {
  718.     # We are inside an #if, but have not yet #defined its xsubpp variable.
  719.     print "#define $cpp_next_tmp 1\n\n";
  720.     push(@InitFileCode, "#if $cpp_next_tmp\n");
  721.     push(@BootCode,     "#if $cpp_next_tmp");
  722.     $XSStack[$XSS_work_idx]{varname} = $cpp_next_tmp++;
  723.     }
  724.  
  725.     death ("Code is not inside a function")
  726.     if $line[0] =~ /^\s/;
  727.  
  728.     # initialize info arrays
  729.     undef(%args_match);
  730.     undef(%var_types);
  731.     undef(%var_addr);
  732.     undef(%defaults);
  733.     undef($class);
  734.     undef($static);
  735.     undef($elipsis);
  736.     undef($wantRETVAL) ;
  737.     undef(%arg_list) ;
  738.     undef(@proto_arg) ;
  739.     undef($proto_in_this_xsub) ;
  740.     $ProtoThisXSUB = $WantPrototypes ;
  741.  
  742.     $_ = shift(@line);
  743.     while ($kwd = check_keyword("REQUIRE|PROTOTYPES|VERSIONCHECK|INCLUDE")) {
  744.         &{"${kwd}_handler"}() ;
  745.         next PARAGRAPH unless @line ;
  746.         $_ = shift(@line);
  747.     }
  748.  
  749.     if (check_keyword("BOOT")) {
  750.     &check_cpp;
  751.         push (@BootCode, $_, @line, "") ;
  752.         next PARAGRAPH ;
  753.     }
  754.  
  755.  
  756.     # extract return type, function name and arguments
  757.     my($ret_type) = TidyType($_);
  758.  
  759.     # a function definition needs at least 2 lines
  760.     blurt ("Error: Function definition too short '$ret_type'"), next PARAGRAPH
  761.     unless @line ;
  762.  
  763.     $static = 1 if $ret_type =~ s/^static\s+//;
  764.  
  765.     $func_header = shift(@line);
  766.     blurt ("Error: Cannot parse function definition from '$func_header'"), next PARAGRAPH
  767.     unless $func_header =~ /^(?:([\w:]*)::)?(\w+)\s*\(\s*(.*?)\s*\)\s*$/s;
  768.  
  769.     ($class, $func_name, $orig_args) =  ($1, $2, $3) ;
  770.     ($pname = $func_name) =~ s/^($Prefix)?/$Packprefix/;
  771.     $Full_func_name = "${Packid}_$func_name";
  772.  
  773.     # Check for duplicate function definition
  774.     for $tmp (@XSStack) {
  775.     next unless defined $tmp->{functions}{$Full_func_name};
  776.     Warn("Warning: duplicate function definition '$func_name' detected");
  777.     last;
  778.     }
  779.     $XSStack[$XSS_work_idx]{functions}{$Full_func_name} ++ ;
  780.     %XsubAliases = %XsubAliasValues = ();
  781.  
  782.     @args = split(/\s*,\s*/, $orig_args);
  783.     if (defined($class)) {
  784.     my $arg0 = ((defined($static) or $func_name =~ /^new/) ? "CLASS" : "THIS");
  785.     unshift(@args, $arg0);
  786.     ($orig_args = "$arg0, $orig_args") =~ s/^$arg0, $/$arg0/;
  787.     }
  788.     $orig_args =~ s/"/\\"/g;
  789.     $min_args = $num_args = @args;
  790.     foreach $i (0..$num_args-1) {
  791.         if ($args[$i] =~ s/\.\.\.//) {
  792.             $elipsis = 1;
  793.             $min_args--;
  794.             if ($args[$i] eq '' && $i == $num_args - 1) {
  795.             pop(@args);
  796.             last;
  797.             }
  798.         }
  799.         if ($args[$i] =~ /^([^=]*[^\s=])\s*=\s*(.*)/s) {
  800.             $min_args--;
  801.             $args[$i] = $1;
  802.             $defaults{$args[$i]} = $2;
  803.             $defaults{$args[$i]} =~ s/"/\\"/g;
  804.         }
  805.         $proto_arg[$i+1] = '$' ;
  806.     }
  807.     if (defined($class)) {
  808.         $func_args = join(", ", @args[1..$#args]);
  809.     } else {
  810.         $func_args = join(", ", @args);
  811.     }
  812.     @args_match{@args} = 1..@args;
  813.  
  814.     $PPCODE = grep(/^\s*PPCODE\s*:/, @line);
  815.     $ALIAS  = grep(/^\s*ALIAS\s*:/,  @line);
  816.  
  817.     # print function header
  818.     print Q<<"EOF";
  819. #XS(XS_${Packid}_$func_name)
  820. #[[
  821. #    dXSARGS;
  822. EOF
  823.     print Q<<"EOF" if $ALIAS ;
  824. #    dXSI32;
  825. EOF
  826.     if ($elipsis) {
  827.     $cond = ($min_args ? qq(items < $min_args) : 0);
  828.     }
  829.     elsif ($min_args == $num_args) {
  830.     $cond = qq(items != $min_args);
  831.     }
  832.     else {
  833.     $cond = qq(items < $min_args || items > $num_args);
  834.     }
  835.  
  836.     print Q<<"EOF" if $except;
  837. #    char errbuf[1024];
  838. #    *errbuf = '\0';
  839. EOF
  840.  
  841.     if ($ALIAS) 
  842.       { print Q<<"EOF" if $cond }
  843. #    if ($cond)
  844. #       croak("Usage: %s($orig_args)", GvNAME(CvGV(cv)));
  845. EOF
  846.     else 
  847.       { print Q<<"EOF" if $cond }
  848. #    if ($cond)
  849. #    croak("Usage: $pname($orig_args)");
  850. EOF
  851.  
  852.     print Q<<"EOF" if $PPCODE;
  853. #    SP -= items;
  854. EOF
  855.  
  856.     # Now do a block of some sort.
  857.  
  858.     $condnum = 0;
  859.     $cond = '';            # last CASE: condidional
  860.     push(@line, "$END:");
  861.     push(@line_no, $line_no[-1]);
  862.     $_ = '';
  863.     &check_cpp;
  864.     while (@line) {
  865.     &CASE_handler if check_keyword("CASE");
  866.     print Q<<"EOF";
  867. #   $except [[
  868. EOF
  869.  
  870.     # do initialization of input variables
  871.     $thisdone = 0;
  872.     $retvaldone = 0;
  873.     $deferred = "";
  874.     %arg_list = () ;
  875.         $gotRETVAL = 0;
  876.  
  877.     INPUT_handler() ;
  878.     process_keyword("INPUT|PREINIT|ALIAS|PROTOTYPE") ;
  879.  
  880.     if (!$thisdone && defined($class)) {
  881.         if (defined($static) or $func_name =~ /^new/) {
  882.         print "\tchar *";
  883.         $var_types{"CLASS"} = "char *";
  884.         &generate_init("char *", 1, "CLASS");
  885.         }
  886.         else {
  887.         print "\t$class *";
  888.         $var_types{"THIS"} = "$class *";
  889.         &generate_init("$class *", 1, "THIS");
  890.         }
  891.     }
  892.  
  893.     # do code
  894.     if (/^\s*NOT_IMPLEMENTED_YET/) {
  895.         print "\n\tcroak(\"$pname: not implemented yet\");\n";
  896.         $_ = '' ;
  897.     } else {
  898.         if ($ret_type ne "void") {
  899.             print "\t" . &map_type($ret_type) . "\tRETVAL;\n"
  900.                 if !$retvaldone;
  901.             $args_match{"RETVAL"} = 0;
  902.             $var_types{"RETVAL"} = $ret_type;
  903.         }
  904.         print $deferred;
  905.                 process_keyword("INIT|ALIAS|PROTOTYPE") ;
  906.  
  907.         if (check_keyword("PPCODE")) {
  908.             print_section();
  909.             death ("PPCODE must be last thing") if @line;
  910.             print "\tPUTBACK;\n\treturn;\n";
  911.         } elsif (check_keyword("CODE")) {
  912.             print_section() ;
  913.         } elsif (defined($class) and $func_name eq "DESTROY") {
  914.             print "\n\t";
  915.             print "delete THIS;\n";
  916.         } else {
  917.             print "\n\t";
  918.             if ($ret_type ne "void") {
  919.                 print "RETVAL = ";
  920.                 $wantRETVAL = 1;
  921.             }
  922.             if (defined($static)) {
  923.                 if ($func_name =~ /^new/) {
  924.                 $func_name = "$class";
  925.                 } else {
  926.                 print "${class}::";
  927.                 }
  928.             } elsif (defined($class)) {
  929.                 if ($func_name =~ /^new/) {
  930.                 $func_name .= " $class";
  931.                 } else {
  932.                 print "THIS->";
  933.                 }
  934.             }
  935.             $func_name =~ s/^($spat)//
  936.                 if defined($spat);
  937.             print "$func_name($func_args);\n";
  938.         }
  939.     }
  940.  
  941.     # do output variables
  942.     $gotRETVAL = 0;
  943.     undef $RETVAL_code ;
  944.     undef %outargs ;
  945.         process_keyword("OUTPUT|ALIAS|PROTOTYPE"); 
  946.  
  947.     # all OUTPUT done, so now push the return value on the stack
  948.     if ($gotRETVAL && $RETVAL_code) {
  949.         print "\t$RETVAL_code\n";
  950.     } elsif ($gotRETVAL || $wantRETVAL) {
  951.         &generate_output($ret_type, 0, 'RETVAL');
  952.     }
  953.  
  954.     # do cleanup
  955.     process_keyword("CLEANUP|ALIAS|PROTOTYPE") ;
  956.  
  957.     # print function trailer
  958.     print Q<<EOF;
  959. #    ]]
  960. EOF
  961.     print Q<<EOF if $except;
  962. #    BEGHANDLERS
  963. #    CATCHALL
  964. #    sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason);
  965. #    ENDHANDLERS
  966. EOF
  967.     if (check_keyword("CASE")) {
  968.         blurt ("Error: No `CASE:' at top of function")
  969.         unless $condnum;
  970.         $_ = "CASE: $_";    # Restore CASE: label
  971.         next;
  972.     }
  973.     last if $_ eq "$END:";
  974.     death(/^$BLOCK_re/o ? "Misplaced `$1:'" : "Junk at end of function");
  975.     }
  976.  
  977.     print Q<<EOF if $except;
  978. #    if (errbuf[0])
  979. #    croak(errbuf);
  980. EOF
  981.  
  982.     print Q<<EOF unless $PPCODE;
  983. #    XSRETURN(1);
  984. EOF
  985.  
  986.     print Q<<EOF;
  987. #]]
  988. #
  989. EOF
  990.  
  991.     my $newXS = "newXS" ;
  992.     my $proto = "" ;
  993.  
  994.     # Build the prototype string for the xsub
  995.     if ($ProtoThisXSUB) {
  996.     $newXS = "newXSproto";
  997.  
  998.     if ($ProtoThisXSUB == 2) {
  999.         # User has specified empty prototype
  1000.         $proto = ', ""' ;
  1001.     }
  1002.         elsif ($ProtoThisXSUB != 1) {
  1003.             # User has specified a prototype
  1004.             $proto = ', "' . $ProtoThisXSUB . '"';
  1005.         }
  1006.         else {
  1007.         my $s = ';';
  1008.             if ($min_args < $num_args)  {
  1009.                 $s = ''; 
  1010.         $proto_arg[$min_args] .= ";" ;
  1011.         }
  1012.             push @proto_arg, "$s\@" 
  1013.                 if $elipsis ;
  1014.     
  1015.             $proto = ', "' . join ("", @proto_arg) . '"';
  1016.         }
  1017.     }
  1018.  
  1019.     if (%XsubAliases) {
  1020.     $XsubAliases{$pname} = 0 
  1021.         unless defined $XsubAliases{$pname} ;
  1022.     while ( ($name, $value) = each %XsubAliases) {
  1023.         push(@InitFileCode, Q<<"EOF");
  1024. #        cv = newXS(\"$name\", XS_$Full_func_name, file);
  1025. #        XSANY.any_i32 = $value ;
  1026. EOF
  1027.     push(@InitFileCode, Q<<"EOF") if $proto;
  1028. #        sv_setpv((SV*)cv$proto) ;
  1029. EOF
  1030.         }
  1031.     }
  1032.     else {
  1033.     push(@InitFileCode,
  1034.          "        ${newXS}(\"$pname\", XS_$Full_func_name, file$proto);\n");
  1035.     }
  1036. }
  1037.  
  1038. # print initialization routine
  1039. print Q<<"EOF";
  1040. ##ifdef __cplusplus
  1041. #extern "C"
  1042. ##endif
  1043. #XS(boot_$Module_cname)
  1044. #[[
  1045. #    dXSARGS;
  1046. #    char* file = __FILE__;
  1047. #
  1048. EOF
  1049.  
  1050. print Q<<"EOF" if $WantVersionChk ;
  1051. #    XS_VERSION_BOOTCHECK ;
  1052. #
  1053. EOF
  1054.  
  1055. print Q<<"EOF" if defined $XsubAliases ;
  1056. #    {
  1057. #        CV * cv ;
  1058. #
  1059. EOF
  1060.  
  1061. print @InitFileCode;
  1062.  
  1063. print Q<<"EOF" if defined $XsubAliases ;
  1064. #    }
  1065. EOF
  1066.  
  1067. if (@BootCode)
  1068. {
  1069.     print "\n    /* Initialisation Section */\n" ;
  1070.     print grep (s/$/\n/, @BootCode) ;
  1071.     print "\n    /* End of Initialisation Section */\n\n" ;
  1072. }
  1073.  
  1074. print Q<<"EOF";;
  1075. #    ST(0) = &sv_yes;
  1076. #    XSRETURN(1);
  1077. #]]
  1078. EOF
  1079.  
  1080. warn("Please specify prototyping behavior for $filename (see perlxs manual)\n") 
  1081.     unless $ProtoUsed ;
  1082. &Exit;
  1083.  
  1084.  
  1085. sub output_init {
  1086.     local($type, $num, $init) = @_;
  1087.     local($arg) = "ST(" . ($num - 1) . ")";
  1088.  
  1089.     eval qq/print " $init\\\n"/;
  1090. }
  1091.  
  1092. sub Warn
  1093. {
  1094.     # work out the line number
  1095.     my $line_no = $line_no[@line_no - @line -1] ;
  1096.  
  1097.     print STDERR "@_ in $filename, line $line_no\n" ;
  1098. }
  1099.  
  1100. sub blurt 
  1101. { 
  1102.     Warn @_ ;
  1103.     $errors ++ 
  1104. }
  1105.  
  1106. sub death
  1107. {
  1108.     Warn @_ ;
  1109.     exit 1 ;
  1110. }
  1111.  
  1112. sub generate_init {
  1113.     local($type, $num, $var) = @_;
  1114.     local($arg) = "ST(" . ($num - 1) . ")";
  1115.     local($argoff) = $num - 1;
  1116.     local($ntype);
  1117.     local($tk);
  1118.  
  1119.     $type = TidyType($type) ;
  1120.     blurt("Error: '$type' not in typemap"), return 
  1121.     unless defined($type_kind{$type});
  1122.  
  1123.     ($ntype = $type) =~ s/\s*\*/Ptr/g;
  1124.     ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
  1125.     $tk = $type_kind{$type};
  1126.     $tk =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/;
  1127.     $type =~ tr/:/_/;
  1128.     blurt("Error: No INPUT definition for type '$type' found"), return
  1129.         unless defined $input_expr{$tk} ;
  1130.     $expr = $input_expr{$tk};
  1131.     if ($expr =~ /DO_ARRAY_ELEM/) {
  1132.         blurt("Error: '$subtype' not in typemap"), return 
  1133.         unless defined($type_kind{$subtype});
  1134.         blurt("Error: No INPUT definition for type '$subtype' found"), return
  1135.             unless defined $input_expr{$type_kind{$subtype}} ;
  1136.     $subexpr = $input_expr{$type_kind{$subtype}};
  1137.     $subexpr =~ s/ntype/subtype/g;
  1138.     $subexpr =~ s/\$arg/ST(ix_$var)/g;
  1139.     $subexpr =~ s/\n\t/\n\t\t/g;
  1140.     $subexpr =~ s/is not of (.*")/[arg %d] is not of $1, ix_$var + 1/g;
  1141.     $subexpr =~ s/\$var/${var}[ix_$var - $argoff]/;
  1142.     $expr =~ s/DO_ARRAY_ELEM/$subexpr/;
  1143.     }
  1144.     if (defined($defaults{$var})) {
  1145.         $expr =~ s/(\t+)/$1    /g;
  1146.         $expr =~ s/        /\t/g;
  1147.         eval qq/print "\\t$var;\\n"/;
  1148.         $deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t    $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/;
  1149.     } elsif ($expr !~ /^\t\$var =/) {
  1150.         eval qq/print "\\t$var;\\n"/;
  1151.         $deferred .= eval qq/"\\n$expr;\\n"/;
  1152.     } else {
  1153.         eval qq/print "$expr;\\n"/;
  1154.     }
  1155. }
  1156.  
  1157. sub generate_output {
  1158.     local($type, $num, $var) = @_;
  1159.     local($arg) = "ST(" . ($num - ($num != 0)) . ")";
  1160.     local($argoff) = $num - 1;
  1161.     local($ntype);
  1162.  
  1163.     $type = TidyType($type) ;
  1164.     if ($type =~ /^array\(([^,]*),(.*)\)/) {
  1165.         print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1)), XFree((char *)$var);\n";
  1166.     } else {
  1167.         blurt("Error: '$type' not in typemap"), return
  1168.         unless defined($type_kind{$type});
  1169.             blurt("Error: No OUTPUT definition for type '$type' found"), return
  1170.                 unless defined $output_expr{$type_kind{$type}} ;
  1171.         ($ntype = $type) =~ s/\s*\*/Ptr/g;
  1172.         $ntype =~ s/\(\)//g;
  1173.         ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
  1174.         $expr = $output_expr{$type_kind{$type}};
  1175.         if ($expr =~ /DO_ARRAY_ELEM/) {
  1176.             blurt("Error: '$subtype' not in typemap"), return
  1177.             unless defined($type_kind{$subtype});
  1178.                 blurt("Error: No OUTPUT definition for type '$subtype' found"), return
  1179.                     unless defined $output_expr{$type_kind{$subtype}} ;
  1180.         $subexpr = $output_expr{$type_kind{$subtype}};
  1181.         $subexpr =~ s/ntype/subtype/g;
  1182.         $subexpr =~ s/\$arg/ST(ix_$var)/g;
  1183.         $subexpr =~ s/\$var/${var}[ix_$var]/g;
  1184.         $subexpr =~ s/\n\t/\n\t\t/g;
  1185.         $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/;
  1186.         eval "print qq\a$expr\a";
  1187.         }
  1188.         elsif ($var eq 'RETVAL') {
  1189.         if ($expr =~ /^\t\$arg = /) {
  1190.             eval "print qq\a$expr\a";
  1191.             print "\tsv_2mortal(ST(0));\n";
  1192.         }
  1193.         else {
  1194.             print "\tST(0) = sv_newmortal();\n";
  1195.             eval "print qq\a$expr\a";
  1196.         }
  1197.         }
  1198.         elsif ($arg =~ /^ST\(\d+\)$/) {
  1199.         eval "print qq\a$expr\a";
  1200.         }
  1201.     }
  1202. }
  1203.  
  1204. sub map_type {
  1205.     my($type) = @_;
  1206.  
  1207.     $type =~ tr/:/_/;
  1208.     $type =~ s/^array\(([^,]*),(.*)\).*/$1 */s;
  1209.     $type;
  1210. }
  1211.  
  1212.  
  1213. sub Exit {
  1214. # If this is VMS, the exit status has meaning to the shell, so we
  1215. # use a predictable value (SS$_Normal or SS$_Abort) rather than an
  1216. # arbitrary number.
  1217.     exit ($Is_VMS ? ($errors ? 44 : 1) : $errors) ;
  1218. }
  1219.